home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
FM Towns: Free Software Collection 10
/
FM Towns Free Software Collection 10.iso
/
ms_dos
/
lib
/
happysrc
/
pcdcl.c
< prev
next >
Wrap
Text File
|
1992-12-15
|
30KB
|
747 lines
/**********************************************************************
*
* *** HAPPy Pascal Compiler ***
*
* 宣言部のコンパイル
*
* ラベル宣言部 void labeldecl(Set fsys)
* 定数定義部 void constdecl(Set fsys)
* 型定義部 void typedecl(Set fsys)
* 変数宣言部 void vardecl(Set fsys,ctp *fprocp)
* 手続き/関数宣言部 void procfuncdecl
* (Set fsys,enum symbol fsy,ctp **pffwdptr)
*
* Copyrignt (c) H.Asano 1992
*
**********************************************************************/
#define EXTERN extern
#include <string.h>
#include "pascomp.h"
extern void block(Set,enum symbol,ctp*);
extern int crelabel(void) ;
extern void pcerr(int,char*) ;
extern char *inttoch(long) ;
extern char *inttoch(long) ;
extern Set *mkset(Set*,int,...) ;
extern Set *orset(Set*,Set*) ;
extern void insymbol(void) ;
extern void skip(Set) ;
extern void updatelc(int) ;
extern ctp *mkctp(char*,enum idclass,stp*,ctp*) ;
extern void enterid(ctp*) ;
extern ctp *searchid(Set) ;
extern ctp *searchsection(ctp*) ;
extern boolean typ(Set, stp**,int*) ;
extern void constant(Set,stp**,union valu*) ;
extern int align(stp*,int) ;
extern void applied(ctp*,int) ;
extern ctp *mkctp(char*,enum idclass,stp*,ctp*) ;
extern void *Malloc(int) ;
extern void *mark(void) ;
extern void release(void*) ;
extern void putfilename(char*,int,int);
/*********************************************/
/* labeldecl() : label宣言部コンパイル */
/*********************************************/
void labeldecl(Set fsys)
{
lbp *llp ;
boolean redef ; /* redefine flag */
boolean test ; /* 繰り返しのために使う */
Set ws ; /* 作業用集合 */
do {
if(sy == intconst) { /* 整数の時 */
redef = false ;
llp = display[top].flabel ;
while(llp) { /* label テーブル サーチ */
if(llp->labval != (int)val.ival) llp = llp->nextlab ;
else { /* 同じ値があった */
redef = true ;
pcerr(166,inttoch(val.ival)) ; /* ラベルが再度宣言された */
break ;
}
}
if(! redef) { /* 再宣言でないとき (OKの時)*/
llp = (lbp*)Malloc(sizeof(lbp)) ; /* label テーブル 確保 */
llp->labval = (int)val.ival ; /* ラベル値 */
llp->labname = crelabel() ; /* P-codeのラベル名生成 */
llp->defined = false ; /* 定義未とする */
llp->nextlab = display[top].flabel ;
display[top].flabel = llp ; /* ポインタのつなぎかえ */
if((val.ival < 0) || (val.ival > 9999)) /* 0~9999の間でない時*/
pcerr(164,"") ; /* ラベルが誤っている */
}
insymbol() ;
}
else pcerr(164,"") ; /* 整数でない時 ラベル誤り */
mkset(&ws, comma,semicolon, -1) ;
orset(&ws, &fsys) ;
if( ! inset(ws,sy)) { /* 次のsymbolの正当性チェック */
pcerr(6,"") ; /* 不当な記号が現れた */
skip(ws) ; /* 正しいところまで読み飛ばし */
}
test = (sy == comma) ;
if(test) insymbol() ; /* , ならば次のsymbolを読む */
} while(test) ; /* , であれば繰り返す */
if(sy == semicolon) insymbol() ; /* ; だったら次のsymbol */
else pcerr(14,""); /* ; がない */
}
/*********************************************/
/* constdecl() : 定数定義部のコンパイル */
/*********************************************/
void constdecl(Set fsys)
{
ctp *lcp ;
stp *lsp ;
union valu lvalu ;
Set ws1 ;
Set ws2 ;
ws1 = fsys ;
addset(ws1, ident) ; /* ws1 = fsys + [ident] */
ws2 = fsys ;
addset(ws2, semicolon) ; /* ws2 = fsys + [semicolon] */
if(sy != ident) {
pcerr(2,id) ; /* 名前がない */
skip(ws1) ; /* fsys+[ident]まで読み飛ばし */
}
while(sy == ident) {
lcp = mkctp(id,konst,nil,nil) ;
insymbol() ;
if(op == eqop) insymbol() ; /* = なら 次のsymbolを読む */
else pcerr(16,"") ; /* = がない */
constant(ws2, &lsp, &lvalu) ; /* 右辺の処理 */
lcp->idtype = lsp ; /* 右辺の型 (lsp) */
lcp->n.values = lvalu ; /* 右辺の値 (lavlu) */
enterid(lcp) ; /* 左辺の名前を登録 */
if(sy == semicolon) { /* ; ならば */
insymbol() ; /* 次のsymbolを読む */
if( ! inset(ws1,sy)) { /* fsysまたは名前でない */
pcerr(6,"") ; /* 不当な記号が現れた */
skip(ws1) ; /* fsys+identのsymbolまでskip */
}
} else pcerr(14,"") ; /* ; がない */
}
}
/*********************************************/
/* typedecl() : 型定義部のコンパイル */
/*********************************************/
void typedecl(Set fsys)
{
ctp *lcp ;
ctp *lcp1 ; /* 前方参照解決用 */
ctp *lcp2 ; /* lcp1の1つ前の値 */
stp *lsp ;
int lsize ;
Set ws ;
typevar = true ; /* 型定義部での型の処理 */
if(sy != ident) { /* 名前でない */
pcerr(2,"") ; /* 名前がない */
mkset(&ws, ident, -1) ;
orset(&ws, &fsys) ;
skip(ws) ; /* fsys+[ident] まで読み飛ばし*/
}
while(sy == ident) { /* */
lcp = mkctp(id,types,nil,nil) ; /* 名前のエリアを確保 */
insymbol() ;
if(op == eqop) insymbol() ; /* = ならば次のsymbol */
else pcerr(16,"") ; /* =がない */
mkset(&ws, semicolon,-1) ;
orset(&ws,&fsys) ;
typ(ws, &lsp, &lsize) ;
if(lsp && !lsp->assignflag && lsp->form != files)
/* ファイル型を含む型の時 */
pcerr(608,"") ; /* 局所ファイルは駄目 */
lcp->idtype = lsp ;
enterid(lcp) ;
/*** 前方参照リストのうち今定義された型を参照しているものを解決 ***/
lcp1 = fwptr ;
while(lcp1) {
if(strcmp(lcp1->name, lcp->name) == 0) { /* 型名が等しい */
lcp1->idtype->sf.pt.eltype = lcp->idtype ; /* 型を入れる */
if(lcp1 != fwptr) lcp2->next = lcp1->next ; /* チェーンから外す*/
else fwptr = lcp1->next ; /* fwptr先頭の時は次を新fwptrに */
}
else lcp2 = lcp1 ; /* 次のループのために退避 */
lcp1 = lcp1->next ;
}
if(sy == semicolon) {
insymbol() ;
mkset(&ws,ident,-1) ;
orset(&ws,&fsys) ;
if(! inset(ws,sy)) {
pcerr(6,"") ; /* 不当な記号が現れた */
skip(ws) ; /* fsys+[ident]まで読み飛ばし */
}
} else pcerr(14,"") ; /* ; がない */
}
while(fwptr) { /* 前方参照が未解決の時 */
pcerr(117,fwptr->name) ; /* 前方参照未解決 */
fwptr = fwptr->next ;
} ;
}
/*********************************************/
/* vardecl() : var節のコンパイル */
/*********************************************/
void vardecl(Set fsys,ctp *fprocp)
{
static fileno = 0 ;
ctp *lcp ;
ctp *nxt ;
stp *lsp ;
extfilep *extp ;
int lsize ;
boolean test;
boolean notfound ;
Set ws ;
nxt = nil ;
typevar = false ; /* 変数定義部での型の処理 */
do {
do {
if(sy == ident) {
lcp = mkctp(id,vars,nil,nxt) ; /* 名前を変数として登録 */
lcp->n.v.vkind = actual ;
lcp->n.v.vlev = level ;
enterid(lcp) ;
nxt = lcp ;
insymbol() ;
}
else pcerr(2,id) ; /* 名前がない */
mkset(&ws, comma, colon, -1) ; /* ws = [comma,colon] */
orset(&ws, &fsys) ; /* + fsys */
orset(&ws, &typedels) ; /* + typedels */
if(! inset(ws,sy)) {
pcerr(6,"") ; /* 不当な記号が現れた */
addset(ws,semicolon) ;
skip(ws) ; /* 誤り回復のため読み飛ばし */
}
if(test = (sy == comma)) insymbol() ; /* , なら次のsymbol */
} while(test) ; /* , なら繰り返す */
if(sy == colon) insymbol() ; /* : なら次のsymbol */
else pcerr(5,"") ; /* : がない */
ws = fsys ;
orset(&ws,&typedels) ;
addset(ws,semicolon) ;
typ(ws, &lsp, &lsize) ;
if(lsp && !lsp->assignflag && lsp->form != files)
/* ファイル型を含む型の時 */
pcerr(608,"") ; /* 局所ファイルは駄目 */
while(nxt) {
updatelc(align(lsp,lc) - lc); /* 変数の割りつけ開始番地 */
nxt->idtype = lsp ; /* 変数の型 */
nxt->n.v.vaddr = lc ; /* 変数の割りつけ番地 */
if(lsp && lsp->form == files) /* ファイル変数の時 */
if(!fprocp && fextfilep) { /* メインブロックで
プログラム引数がある時 */
extp = fextfilep ;
notfound = true ;
while(extp && notfound) { /* プログラム引数と照合 */
if(!strcmp(extp->filename,nxt->name)) { /* 引数に書いた名前 */
if(++fileno > Maxfileno) /* 最大ファイル数を越えている */
pcerr(600,inttoch((long)Maxfileno)) ;
putfilename(nxt->name,lc,nxt->idtype->size) ;
/* ファイル情報を出力する */
notfound = false ;
}
extp = extp->nextfile ;
}
if(notfound) pcerr(608,"") ; /* 局所ファイルは駄目 */
}
else pcerr(608,"") ; /* メインブロック以外または
プログラム引数がない時 */
updatelc(lsize) ; /* lc 更新 */
nxt = nxt->next ;
}
if(sy == semicolon) {
insymbol() ;
ws = fsys ;
addset(ws,ident) ;
if(! inset(ws,sy)) {
pcerr(6,"") ; /* 不当な記号が現れた */
skip(ws) ; /* fsys+[ident]まで読み飛ばし */
}
}
else pcerr(14,"") ; /* ; がない */
} while((sy == ident) || (inset(typedels,sy))) ;
}
/*************************************************/
/* procfuncdecl() : procedure/function宣言部の */
/* コンパイル */
/*************************************************/
typedef enum prmkind { normal, /* ブロックと結合された引数 */
procfunc } /* 関数、手続き引数の引数 */
prmkind ;
static void pfparmlist(ctp**,Set,Set,boolean,prmkind) ;
static void functype(Set,ctp*,boolean) ;
static ctp *pfident(Set,enum symbol,boolean*,boolean*) ;
static void prmpflist(Set,ctp**,prmkind) ;
static void prmvarlist(Set,Set,ctp**,prmkind) ;
void procfuncdecl(Set fsys,enum symbol fsy,ctp **pffwdptr)
{
int oldlc ; /* location counter 退避域 */
int oldlevel ; /* level退避域 */
int oldtop ; /* top退避域 */
ctp *lcp ; /* proc/funcの名前ポインタ */
ctp *lcp1,*lcp2 ; /* 前方宣言解決用のポインタ */
void *markadr ; /* 一括解放アドレス */
boolean forw ; /* すでに宣言されている時true */
boolean err160 ;
Set ws ;
oldlc = lc ; /* 今のlocation counterを退避 */
lc = lcaftermarkstack ; /* 新しくlcを初期設定 */
lcp = pfident(fsys,fsy,&forw,&err160) ; /* 名前の処理 */
oldlevel = level ; /* 今の水準を退避 */
oldtop = top ; /* 今のdisplay先頭位置を退避 */
if(level < Maxlevel) level++ ; /* 水準オーバでなければ水準を増やす*/
else pcerr(604,inttoch((long)Maxlevel)) ;
/* 手続き・関数の入れ子が深すぎ*/
if(top < Displimit) { /* displayがまだある時 */
top++ ; /* 新しい水準のdisplay初期設定*/
display[top].fname = (forw) ? lcp->next : nil ;
display[top].flabel = nil ;
display[top].aname = nil ;
display[top].occur = blck ;
display[top].funcname = (fsy==funcsy) ? lcp : nil ; /* 関数名 */
display[top].funcassign = false ; /* 関数への代入未(手続き無効) */
}
else pcerr(603,inttoch((long)Displimit)) ;
/* 名前の入れ子が深すぎる */
if(fsy == procsy) { /* 手続きの時 */
mkset(&ws,semicolon,-1) ;
pfparmlist(&(lcp->next),ws,fsys,forw,normal) ;
}
else {
mkset(&ws,semicolon,colon,-1);
pfparmlist(&(lcp->next),ws,fsys,forw,normal) ;
functype(fsys,lcp,forw); /* 関数の型の処理 */
}
if(sy == semicolon) insymbol() ;
else pcerr(14,"") ; /* ; がない */
if((sy==ident) && (strcmp(id,"forward")==0)) {
/* forward指令があった時 */
if(forw)
pcerr(161,lcp->name) ; /* 再び前方宣言された */
else if(!err160 && ((lcp->klass==proc) || (lcp->klass==func))) {
lcp->n.pf.sd.d.af.a.fwdptr=*pffwdptr; /* 前方宣言名をつなぐ */
*pffwdptr = lcp ;
lcp->n.pf.sd.d.af.a.forwdecl = true ;
}
insymbol() ;
if(sy == semicolon) insymbol() ;
else pcerr(14,"") ; /* ; がない */
if(! inset(fsys,sy)) { /* 終端記号にない時 */
pcerr(6,"") ; /* 不当な記号が現れた */
skip(fsys) ; /* 読み飛ばし */
}
}
else { /* forward指令がない時 */
lcp->n.pf.sd.d.af.a.forwdecl = false ;
lcp1 = *pffwdptr ; /* 前方宣言リストから外す */
while(lcp1) {
if(strcmp(lcp1->name,lcp->name) == 0) {
if(lcp1 != *pffwdptr)
lcp2->n.pf.sd.d.af.a.fwdptr = lcp1->n.pf.sd.d.af.a.fwdptr ;
else *pffwdptr = lcp1->n.pf.sd.d.af.a.fwdptr ;
}
else lcp2 = lcp1 ;
lcp1 = lcp1->n.pf.sd.d.af.a.fwdptr ;
}
markadr = mark() ; /* 一括解放アドレスをマーク */
do {
block(fsys,semicolon,lcp) ; /* ブロック処理 */
if(sy == semicolon) {
insymbol() ;
mkset(&ws,beginsy,procsy,funcsy,-1);
if(! inset(ws,sy)) {
pcerr(6,"") ; /* 不当な記号が現れた */
skip(ws) ; /* 読み飛ばし */
}
}
else pcerr(14,"") ; /* ; がない */
} while(! inset(ws,sy)) ; /* begin,procedure,functionなら抜ける*/
release(markadr) ; /* heapメモリを一括解放 */
}
level = oldlevel ; /* 前の水準に復帰 */
top = oldtop ; /* 前のdisplay先頭に復帰 */
lc = oldlc ; /* 前のlocation counterに復帰 */
}
/***************************************/
/* pfident() : proc/funcの名前の処理 */
/***************************************/
static ctp *pfident(Set fsys,enum symbol fsy,boolean *ffwd,boolean *err160)
{
ctp *lcp,*lcp1 ;
boolean forw = false ; /* 前方参照宣言フラグ */
*err160 = false ;
if(sy != ident) { /* 名前でない */
pcerr(2,"") ; /* 名前がない */
insymbol() ;
return(ufctptr) ; /* 未定義用の名前エリアを返却*/
}
lcp = searchsection(display[top].fname) ; /* 同じ水準から名前を探す*/
if(lcp) /* 名前が見つかった */
if((lcp->klass == proc) || (lcp->klass == func)) { /*forward宣言*/
forw = (((lcp->klass==proc) && (fsy==procsy)) || /*されている */
((lcp->klass==func) && (fsy==funcsy))) /*かチェック */
&& (lcp->n.pf.sd.d.pfkind==actual)
&& (lcp->n.pf.sd.d.af.a.forwdecl) ;
if(! forw) {
pcerr(160,id) ; /* 既に正式な宣言が行われている*/
*err160 = true ; /* かなりヤクザなやり方です */
forw = true ;
}
}
else pcerr(101,lcp->name); /* 名前の二重定義エラー */
else { /* 名前が見つからなかった */
lcp = (fsy == procsy) ? mkctp(id,proc,nil,nil) /* 名前エリア確保*/
: mkctp(id,func,nil,nil) ;
lcp->n.pf.pfdeckind = declared ;
lcp->n.pf.sd.d.pfkind = actual ;
lcp->n.pf.sd.d.pflev = level ;
lcp->n.pf.sd.d.af.a.pfname = crelabel();
enterid(lcp) ; /* 名前の登録 */
}
if(forw) { /* 前方宣言された名前の時 */
lcp1 = lcp->next ; /* 変数の割当をする */
while(lcp1 && lcp1->next) /* 最後の引数を得る */
lcp1 = lcp1->next ;
switch(lcp1->klass) {
case vars : /* 変数 */
updatelc(lcp1->n.v.vaddr - lc) ;
if(lcp1->n.v.vkind==actual){ /* 値引数 */
if(lcp1->idtype) /* 型がエラーでない時 */
updatelc(lcp1->idtype->size); /* サイズ分進める */
}
else /* 変数引数 */
updatelc(ptrsize); /* ポインタサイズだけ進める*/
break ;
case proc :
case func : /* 手続き 関数 */
updatelc((lcp1->n.pf.sd.d.af.f.adradr + ptrsize) - lc) ;
break ;
}
}
insymbol() ;
*ffwd = forw ;
return(lcp) ;
}
/****************************************/
/* functype() : 関数の型処理 */
/****************************************/
static void functype(Set fsys,ctp *fcp,boolean forw)
{
ctp *lcp1;
stp *lsp ;
Set ws ;
if(sy == colon) { /* : の 時 */
insymbol() ; /* 型を読む */
if(sy == ident) {
if(forw) pcerr(122,fcp->name) ; /* 再び型を書いてはいけない */
mkset(&ws,types,-1) ;
lcp1 = searchid(ws) ; /* 型名より探す */
fcp->idtype = lsp = lcp1->idtype ;
if(lsp) {
mkset(&ws,scalar,subrange,pointer,-1);
if(! inset(ws,lsp->form)) { /* 型がスカラ、範囲型、ポインタでない時*/
pcerr(120,fcp->name) ; /* 関数の型の誤り */
fcp->idtype = nil ;
}
}
insymbol() ;
}
else {
pcerr(2,"") ; /* 名前がない */
ws = fsys ;
addset(ws,semicolon) ;
skip(ws) ; /* 読み飛ばし */
}
}
else /* : がない時 */
if(! forw) pcerr(123,fcp->name); /* 関数の宣言に型がない */
}
/*****************************************/
/* pfparamlist() : パラメータリスト処理 */
/*****************************************/
static void pfparmlist(ctp **fcp,Set fsys,Set fpfsys,boolean forw,prmkind kind)
{
ctp *lcp1,*lcp2,*lcp3 ;
Set ws,ws1 ;
Set prmbegsys ; /* 引数の最初のsymbolとしてOKのもの*/
mkset(&prmbegsys, ident,varsy,procsy,funcsy, -1);
lcp1 = nil ;
ws = fsys ;
addset(ws,lparent) ;
if(! inset(ws,sy)) {
pcerr(7,"") ; /* 引数の並びに誤りがある */
orset(&ws,&fpfsys) ;
skip(ws) ; /* 読み飛ばし */
}
if(sy == lparent) {
if(forw) pcerr(119,"") ; /* 前方宣言されているので引数は駄目*/
insymbol() ;
if(! inset(prmbegsys,sy)) {
pcerr(7,"") ; /* 引数の並びに誤りがある */
mkset(&ws,ident,rparent,-1) ;
orset(&ws,&fpfsys) ;
skip(ws) ; /* 読み飛ばし */
}
ws = prmbegsys ;
orset(&ws,&fpfsys) ;
while(inset(prmbegsys,sy)) { /* 引数の開始symbolとしてokの間*/
switch(sy) {
case procsy :
case funcsy : prmpflist(fpfsys,&lcp1,kind) ; /* 手続き、関数引数*/
break ;
default : prmvarlist(fsys,fpfsys,&lcp1,kind) ; /* 変数,値引数*/
}
if(sy == semicolon) {
insymbol() ;
if(! inset(ws,sy)) {
pcerr(7,"") ; /* 引数の並びに誤りがある */
mkset(&ws1,ident,rparent,-1);
skip(ws1) ; /* 読み飛ばし */
}
}
}
if(sy == rparent) insymbol() ;
else pcerr(4,"") ; /* ) がない */
}
/* reverse pointers and reserve local cells for copies of
multiple values */
lcp3 = nil ;
while(lcp1) { /* 最初のlcp1は最後のパラメータを指す*/
lcp2 = lcp1->next ;
lcp1->next = lcp3 ;
if(kind == normal) /* ブロックと結合される引数 */
if(lcp1->klass == vars) /* 変数の時 */
if(lcp1->idtype)
if((lcp1->n.v.vkind==actual) && /* 局所変数(値渡し)で */
(lcp1->idtype->form > power)) { /* 配列・レコードの時 */
updatelc(align(lcp1->idtype,lc) - lc) ;
lcp1->n.v.vaddr = lc ; /* 変数アドレス割りつけ */
updatelc(lcp1->idtype->size);
}
lcp3 = lcp1 ;
lcp1 = lcp2 ;
}
if(((kind==normal) && (!forw)) || (kind==procfunc) )
*fcp = lcp3 ; /* 引数の並びを設定 */
}
/*******************************************/
/* prmpflist() : 手続き・関数パラメータ処理 */
/*******************************************/
static void prmpflist(Set fsys,ctp **fcp1,prmkind kind)
{
ctp *lcp;
enum symbol lsy ;
int oldtop ;
Set ws ;
/****** 手続き名・関数名の処理 *****/
lsy = sy ;
insymbol() ;
if(sy != ident) { /* 名前でない */
pcerr(2,"") ; /* 名前がない */
insymbol() ;
lcp = ufctptr ; /* 名前がない時の仮のエリア */
}
else {
lcp = (lsy == procsy) ? mkctp(id,proc,nil,*fcp1)/* 名前エリア確保*/
: mkctp(id,func,nil,*fcp1) ;
lcp->n.pf.pfdeckind = declared ;
lcp->n.pf.sd.d.pfkind = formal ; /* 仮手続き・仮関数 */
lcp->n.pf.sd.d.pflev = level ; /* 定義水準 */
enterid(lcp) ; /* 名前の登録 */
}
*fcp1 = lcp ;
/***** 仮パラメータ並びの処理 *****/
oldtop = top ;
if(top < Displimit) { /* displayがまだある時 */
top++ ; /* 新しい水準のdisplay初期設定*/
display[top].fname = nil ;
display[top].aname = nil ;
display[top].flabel = nil ; /* 意味なし */
display[top].occur = blck ; /* 意味なし */
}
else pcerr(603,inttoch((long)Displimit)) ;
/* 名前の入れ子が深すぎる */
insymbol() ;
if(lsy == procsy) { /* 手続きの時 */
mkset(&ws,rparent,semicolon,-1) ;
pfparmlist(&(lcp->n.pf.sd.d.af.f.prm),ws,fsys,false,procfunc) ;
}
else {
mkset(&ws,rparent,semicolon,colon,-1);
pfparmlist(&(lcp->n.pf.sd.d.af.f.prm),ws,fsys,false,procfunc) ;
functype(fsys,lcp,false); /* 関数の型の処理 */
}
if(kind == normal) { /* ブロックと結合される時 */
updatelc(align(intptr,lc) - lc) ;
lcp->n.pf.sd.d.af.f.levadr = lc ; /* 水準差をのせるアドレス */
updatelc(intsize) ;
updatelc(align(nilptr,lc) - lc) ;
lcp->n.pf.sd.d.af.f.adradr = lc ; /*実行アドレスをのせるアドレス*/
updatelc(ptrsize) ;
}
top = oldtop ;
}
/*****************************************/
/* prmvarlist() : 変数、値パラメータ処理 */
/*****************************************/
static void prmvarlist(Set fsys,Set fpfsys,ctp **fcp1,prmkind kind)
{
enum idkind lkind ; /* actual ・・・ 値パラメータ
formal ・・・ 変数パラメータ */
ctp *lcp,*lcp2,*lcp3 ;
stp *lsp ;
int count = 0 ;
int number = 0 ;
int lsize ;
int llc ;
boolean test ;
Set ws ;
if(sy == varsy) {
lkind = formal ; /* varの付くものは変数引数 */
insymbol() ;
}
else lkind = actual ; /* varが付かなければ値引数 */
lcp2 = nil ;
do {
if(sy == ident) {
lcp = mkctp(id,vars,nil,lcp2) ; /* 変数用のエリアを確保 */
lcp->n.v.vkind = lkind ;
lcp->n.v.vlev = level ;
enterid(lcp) ;
lcp2 = lcp ;
count++ ;
insymbol() ;
}
mkset(&ws,comma,colon,-1);
orset(&ws,&fpfsys) ;
if(! inset(ws,sy)) {
pcerr(7,"") ; /* 引数の並びに誤りがある */
addset(ws,rparent);
skip(ws) ; /* 読み飛ばし */
}
if(test=(sy==comma)) insymbol() ; /* , ならば次のsymbolを読む */
} while(test) ; /* , ならば次の名前の処理 */
if(sy == colon) {
insymbol() ;
if(sy == ident) {
mkset(&ws,types,-1) ;
lcp = searchid(ws) ; /* 型名を探す */
applied(lcp,top) ; /* 引用名チェーン */
lsp = lcp->idtype ;
lsize = ptrsize ; /*配列・レコード・変数パラ=アドレスサイズ*/
if(lsp)
if(lkind == actual) /* 値パラメータ */
if(lsp->form <= power) lsize = lsp->size ; /* スカラ、範囲、ポインタ、集合 */
else if(!lsp->assignflag) pcerr(121,"");
/* ファイルの要素型として許されない*/
if(kind == normal) { /* ブロックと結合される引数 */
lsize = align(parmptr,lsize) ; /* パラメータリストの境界調整 */
updatelc(align(parmptr,lc) - lc);
updatelc(count*lsize) ; /* パラメータリスト領域を確保 */
}
llc = lc ;
lcp3 = lcp2 ; /* 変数並びの最後の変数の名前アドレス*/
while(lcp2) { /* 各変数にエリアを割りつける */
lcp = lcp2;
lcp2->idtype = lsp ; /* 型 */
lcp2->linkno = (char)number++ ; /* 同形リンク番号 */
if(kind == normal) { /* ブロックと結合される引数 */
llc -= lsize ;
lcp2->n.v.vaddr = llc ; /* アドレス割りつけ */
}
lcp2 = lcp2->next ;
}
lcp->next = *fcp1 ; /* 引数をチェーンしていく */
*fcp1 = lcp3 ; /* 次回呼び出しのために */
insymbol() ;
}
else pcerr(2,"") ; /* 名前がない */
mkset(&ws,semicolon,rparent,-1);
orset(&ws,&fpfsys) ;
if(! inset(ws,sy)) {
pcerr(7,"") ; /* 引数の並びに誤りがある */
skip(ws) ; /* 読み飛ばし */
}
}
else pcerr(5,"") ; /* : がない */
}